unit clientdb;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, fpstructs, fposUtils, tcpbuffers, ExtCtrls, db;

type

  TDBErrorEvent = procedure(err: string) of object;
  TDBReceiveFileEvent = procedure(Sender: TObject; buf: TTCPBuffer) of object;
  TSQLMode = (sqlmInsert, sqlmUpdate);

  { TCDBField }

  TCDBField = class (TObject)
  private
    fFieldname: string;
    fDatatype: TFieldType;
    FIsIndexField: Boolean;
    FModified: Boolean;
    FOnChange: TNotifyEvent;
    FReadOnly: Boolean;
    fValue: string;
    function GetAsDateTime: TDateTime;
    function GetAsString: string;
    function GetAsInteger: Integer;
    function GetAsFloat: Double;
    function GetAsBoolean: Boolean;
    function GetisNull: Boolean;
    procedure SetAsBoolean ( const AValue: Boolean ) ;
    procedure SetAsDateTime ( const AValue: TDateTime ) ;
    procedure SetAsFloat ( const AValue: Double ) ;
    procedure SetAsInteger ( const AValue: integer ) ;
    procedure SetAsString ( const AValue: String ) ;
  public
    constructor Create;
    property AsString: String read GetAsString write SetAsString;
    property AsInteger: integer read GetAsInteger write SetAsInteger;
    property AsFloat: Double read GetAsFloat write SetAsFloat;
    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
    property FieldName: string read fFieldname;
    property isNull: Boolean read GetisNull;
    property Datatype: TFieldType read fDatatype write fDatatype;
    property IsIndexField: Boolean read FIsIndexField write FIsIndexField;
    property ReadOnly: Boolean read FReadOnly write FReadOnly;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property Modified: Boolean read FModified write FModified;
  end;


  TFieldArray = array of TCDBField;

  { TDBData }

  TDBData = class(TStringList)   // holds the data, so we can copy it between DBs
  public
    Fields: TFieldArray;
    FieldCount: integer;
    procedure ClearFields;
  end;

  { TBaseDB }

  TBaseDB = class (TObject)
  private
    fData: TDBData;
    FQuery: string;
    FState: TDataSetState;
    FRecNo: Integer;
    FRecordCount: Integer;
    fRecordModified: Boolean;
    fEOF: Boolean;
    FTablename: string;
    function GetFieldCount: integer;
    function GetFields: TFieldArray;
    function GetisEmpty: Boolean;
    procedure SetRecNo ( const AValue: Integer ) ;
    procedure ClearFields;
    procedure RecordChanged( Sender: TObject );
  public
    constructor Create;
    destructor Destroy; override;
    procedure First;
    procedure Last;
    procedure Next;
    procedure Prior;
    procedure Assign( src: TBaseDB );
    procedure Post;
    procedure Insert;
    function FieldByName( fn: string ): TCDBField;
    function ExportRecordAsSQL( sqlmode: TSQLMode ): string;
    property FieldCount: integer read GetFieldCount;
    property RecNo: Integer read FRecNo write SetRecNo;
    property RecordCount: Integer read FRecordCount;
    property EOF: Boolean read fEOF;
    property Fields: TFieldArray read GetFields;
    function FieldIndex(aField: TCDBField): integer;
    property State: TDataSetState read FState;
    property isEmpty: Boolean read GetisEmpty;
    property Dataset: TDBData read fData;
    property Tablename: string read FTablename write FTablename;  //used by RecordAsSQL
    property Query: string read FQuery;
  end;

  { TClientDB }

  TClientDB = class (TBaseDB)
  private
    FOnReceiveFile: TDBReceiveFileEvent;
    fWaiting: Boolean;
    FPort: Integer;
    FServer: string;
    FSQL: string;
    fConnection: TTCPConnection;
    fConnected: Boolean;
    fTimeout: double;
    milliseconds: double;
    fTimeOutTime: double;
    fSuccess: Boolean;
    function GetTimeout: integer;
    procedure SetSQL ( const AValue: string ) ;
    procedure ReceiveMessage ( Sender: TObject ) ;
    procedure DoConnect ( aSocket: TTCPSocket ) ;
    procedure DoDisconnect ( aSocket: TTCPSocket ) ;
    procedure SetTimeout ( const AValue: integer ) ;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Open;
    procedure Close;
    procedure Refresh;
    function ExecRemoteSQL( SQL: string; isUpdate: Boolean=false ): Boolean;
    function Connect: Boolean;
    procedure Disconnect;
    property SQL: string read FSQL write SetSQL;
    property Connection: TTCPConnection read fConnection;
    property Server: string read FServer write FServer;
    property Port: Integer read FPort write FPort;
    property Timeout: integer read GetTimeout write SetTimeout;
    property FieldCount;
    property RecNo;
    property RecordCount;
    property EOF;
    property Fields;
    property State;
    property isEmpty;
    property Dataset;
    property OnReceiveFile: TDBReceiveFileEvent read FOnReceiveFile write FOnReceiveFile;
                    // in thousandths of a second (min:0 ; max 30000)
  end;




implementation

{ TCDBField }

function TCDBField.GetAsString: string;
begin
  Result := UnEscapeLineEnding( fValue );
end;

function TCDBField.GetAsDateTime: TDateTime;
begin
  Result := JulianDateTimeToDateTime( GetAsFloat );
end;

function TCDBField.GetAsInteger: Integer;
var
  i: integer;
begin
  Result := 0;
  if TryStrToInt(fValue, i)
     then Result := i
     else Raise Exception.Create('''' + fValue + ''' is not a valid integer');
end;

function TCDBField.GetAsFloat: Double;
var
  d: Double;
begin
  Result := 0;
  if TryStrToFloat(fValue, d)
     then Result := d
     else Raise Exception.Create('''' + fValue + ''' is not a valid float');
end;

function TCDBField.GetAsBoolean: Boolean;
var
  b: Boolean;
begin
  Result := false;
  if TryStrToBool(fValue, b)
     then Result := b
     else Raise Exception.Create('''' + fValue + ''' is not a valid Boolean');
end;

function TCDBField.GetisNull: Boolean;
begin
  Result := Length(fValue)=0;
end;

procedure TCDBField.SetAsBoolean ( const AValue: Boolean ) ;
var
  V: String;
begin
  V := BoolToStr(AValue);
  if fValue<>V then
     begin
       fValue := V;
       FModified := true;
       if Assigned(FOnChange) then FOnChange(Self);
     end;
end;

procedure TCDBField.SetAsDateTime ( const AValue: TDateTime ) ;
var
  V: String;
begin
  V := DateTimeToJulianDateTimeAsString(AValue);
  if fValue<>V then
     begin
       fValue := V;
       FModified := true;
       if Assigned(FOnChange) then FOnChange(Self);
     end;
 end;

procedure TCDBField.SetAsFloat ( const AValue: Double ) ;
var
  V: String;
begin
  V := FloatToStr(AValue);
  if fValue<>V then
     begin
       fValue := V;
       FModified := true;
       if Assigned(FOnChange) then FOnChange(Self);
     end;
end;

procedure TCDBField.SetAsInteger ( const AValue: integer ) ;
var
  V: String;
begin
  V := IntToStr(AValue);
  if fValue<>V then
     begin
       fValue := V;
       FModified := true;
       if Assigned(FOnChange) then FOnChange(Self);
     end;
end;

procedure TCDBField.SetAsString ( const AValue: String ) ;
begin
  if fValue<>EscapeLineEnding( AValue ) then
     begin
       fValue := EscapeLineEnding( AValue );
       FModified := true;
       if Assigned(FOnChange) then FOnChange(Self);
     end;
end;

constructor TCDBField.Create;
begin
  fDatatype := ftUnknown;
end;

{ TBaseDB  }

procedure TBaseDB.SetRecNo ( const AValue: Integer ) ;
var
  offset: Integer;
  x: Integer;
begin
  if FRecNo = AValue then exit;
  if (AValue<0) or (AValue>=FRecordCount) then exit;
  FRecNo := AValue;
  offset := FRecNo*FieldCount;
  for x := 0 to FieldCount-1 do
      Fields[x].fValue := fData[offset+x];
  fRecordModified := false;
end;

procedure TBaseDB.ClearFields;
begin
  fData.ClearFields;
end;

procedure TBaseDB.RecordChanged ( Sender: TObject ) ;
begin
  fRecordModified := true;
end;

constructor TBaseDB.Create;
begin
  FRecNo := -1;
  fData := TDBData.Create;
  fData.FieldCount := 0;
  FTablename := 'TABLE';
end;

destructor TBaseDB.Destroy;
begin
  fData.Free;
  inherited Destroy;
end;

procedure TBaseDB.First;
begin
  SetRecNo(0);
  fEOF := FRecordCount<1;
end;

procedure TBaseDB.Last;
begin
  SetRecNo(FRecordCount-1);
  fEOF := true;
end;

procedure TBaseDB.Next;
begin
  if FRecNo<FRecordCount-1
     then SetRecNo(FRecNo+1)
     else fEOF := true;
end;

procedure TBaseDB.Prior;
begin
  if FRecNo>0
     then SetRecNo(FRecNo-1);
  fEOF := FRecNo=FRecordCount-1;
end;

procedure TBaseDB.Assign ( src: TBaseDB ) ;
var
  x: Integer;
begin
  fData.ClearFields;
  FRecNo := -1;
  FRecordCount := src.RecordCount;
  fData.FieldCount := src.FieldCount;
  fData.Text := src.fData.Text;
  X := fData.Count;
  SetLength(fData.Fields, FieldCount);
  for x := 0 to FieldCount-1 do          // extract field names
    begin
      fData.Fields[x] := TCDBField.Create;
      fData.Fields[x].fFieldname := src.Fields[x].FieldName;
      fData.Fields[x].OnChange := @RecordChanged;
    end;
  FTablename := src.Tablename;
  FQuery := src.Query;
  SetRecNo(0);
end;

procedure TBaseDB.Post;
var
  offset: Integer;
  fc: Integer;
  x: Integer;
begin
  offset := FieldCount*RecNo;
  fc := FieldCount;
  for x := 0 to fc-1 do
    fData.Strings[x + offset] := fData.Fields[x].fValue;
end;

procedure TBaseDB.Insert;
var
  x: Integer;
begin
  for x := 1 to FieldCount do
    fData.Add('');
  Inc(FRecordCount);
  SetRecNo(FRecordCount-1);
end;

function TBaseDB.FieldByName ( fn: string ) : TCDBField;
var
  x: integer;
begin
  x := 0;
  fn := AnsiLowerCase(fn);
  Result := nil;
  while (x<FieldCount) and (AnsiLowerCase( Fields[x].FieldName )<>fn)
        do Inc(x);
  if x<FieldCount
     then Result := Fields[x];
end;

function TBaseDB.ExportRecordAsSQL ( sqlmode: TSQLMode ) : string;
         function QuoteStrings( astr: string ):string;
         var
           isString: Boolean;
           c: Integer;
         begin
           isString := false;
           c := 1;
           while (c<=Length(astr)) and not isString do
                 begin
                   isString := not (astr[c] in ['0'..'9', '.']);
                   Inc(c);
                 end;
           if isString
              then Result := '"' + astr + '"'
              else Result := astr;
         end;

         function SQLInsertRecord: string;
         var
           sqlstring: String;
           f: Integer;
         begin
           Result := '';
           sqlstring := 'INSERT INTO "' + FTablename + '" (';
           for f := 0 to FieldCount-1 do
             begin
               if not Fields[f].ReadOnly
                  then sqlstring := sqlstring + Fields[f].FieldName + ',';
             end;
           sqlstring[Length(sqlstring)] := ')';
           sqlstring := sqlstring + ' VALUES (';
           for f := 0 to FieldCount-1 do
             if not Fields[f].ReadOnly
               then sqlstring := sqlstring + QuoteStrings( Fields[f].AsString ) + ',';
           sqlstring[Length(sqlstring)] := ')';
           sqlstring := sqlstring + ';';
           SQLInsertRecord := sqlstring;
         end;

         function SQLUpdateRecord: string;
         var
           sqlstring: String;
           f: Integer;
         begin
           Result := '';
           sqlstring := 'UPDATE "' + FTablename + '" SET ';
           for f := 1 to FieldCount-1 do
             sqlstring := sqlstring + Fields[f].FieldName + '=' + QuoteStrings(Fields[f].AsString) + ',';
           sqlstring[Length(sqlstring)] := ' ';
           sqlstring := sqlstring + 'WHERE ' + Fields[0].FieldName + '=' + QuoteStrings(Fields[0].AsString) + ';';
           SQLUpdateRecord := sqlstring;
         end;

begin
  case sqlmode of
  sqlmInsert:  Result := SQLInsertRecord;
  sqlmUpdate:  Result := SQLUpdateRecord;
  end;
end;

function TBaseDB.FieldIndex(aField: TCDBField): integer;
var
  f: Integer;
begin
  f := 0;
  Result := -1;
  while (Result<0) and (f<FieldCount) do
        begin
          if Fields[f]=aField then Result := f;
          Inc(f);
        end;
end;

function TBaseDB.GetisEmpty: Boolean;
begin
  Result := FRecordCount=0;
end;


function TBaseDB.GetFieldCount: integer;
begin
  Result := fData.FieldCount;
end;

function TBaseDB.GetFields: TFieldArray;
begin
  Result := fData.Fields;
end;


{ TClientDB }

procedure TClientDB.SetSQL ( const AValue: string ) ;
begin
  if FSQL = AValue then exit;
  FSQL := AValue;
end;

function TClientDB.GetTimeout: integer;
begin
  Result := StrToint((FormatDateTime('s', fTimeout)) + FormatDateTime('zzz', fTimeout)) ;
end;

procedure TClientDB.ReceiveMessage ( Sender: TObject ) ;
var
  header: tfpHeader;
  buffer: string;
  x: Integer;
  errm: integer;
  afieldcount: integer;
  arecordcount: integer;
  datalength: integer;

begin
  writeln('ReceiveMessage fired');
  errm := -1;
  try
    fWaiting := false;
    if TTCPBuffer(Sender).Header.MessageType=fpmConfirm then
       begin
         if TTCPBuffer(Sender).Header.datalength=0
            then fSuccess := true;
       end
    else if TTCPBuffer(Sender).Header.MessageType=fpmPDFReport then
       begin
         datalength := TTCPBuffer(Sender).Header.datalength;
         SetLength(buffer, datalength);
         if datalength>0
            then if Assigned(FOnReceiveFile)
                 then FOnReceiveFile(Self, TTCPBuffer(Sender));
       end
    else
      begin
        with TTCPBuffer(Sender) do  // incoming data
             begin
               Data.Seek(SizeOf(Header), soFromBeginning);
               Data.Read(errm, SizeOf(errm));
               Data.Read(afieldcount, SizeOf(afieldcount));
               Data.Read(arecordcount, SizeOf(arecordcount));
               Data.Read(datalength, SizeOf(datalength));
               SetLength(buffer, datalength);
               if datalength>0
                  then Data.Read(buffer[1], datalength);
               writeln(buffer);
             end;
             writeln('err=', errm);
        if errm=0 then
           begin
             fData.Clear;
             fData.Text := buffer;
             fData.FieldCount := afieldcount;  //use SetFieldcount to administer array of TCDBField ??
             FRecordCount := arecordcount;
             SetLength(fData.Fields, FieldCount);
             for x := 0 to FieldCount-1 do          // extract field names
               begin
                 fData.Fields[x] := TCDBField.Create;
                 fData.Fields[x].fFieldname := fData[0];
                 fData.Delete(0);
               end;
             if fRecordCount>0 then
                begin
                  SetRecNo(0);
                  if fRecordCount <> (fData.Count div FieldCount)
                     then Raise Exception.CreateFmt('Recordcount discrepancy: %d found but should be %d',
                                           [fData.Count div FieldCount, FRecordCount]);
                end;
             fEOF := false;
             FState := dsBrowse;
           end
        else
           begin
             //Raise Exception.CreateFmt('Database error: %s', [buffer]);
             writeln('Database error: ', buffer);
           end;
                        //NOTE: Exceptions should delete any existing fields
    end;     // incoming data
  finally
    TTCPBuffer(Sender).MessageComplete := true;
//    Disconnect;
  end;
end;

procedure TClientDB.DoConnect ( aSocket: TTCPSocket ) ;
begin
  fConnected := true;
end;

procedure TClientDB.DoDisconnect ( aSocket: TTCPSocket ) ;
begin
  fConnected := false;
end;

procedure TClientDB.SetTimeout ( const AValue: integer ) ;
var
  seconds: Extended;
  val: LongInt;
  timeformattedstring: String;
begin
  val := AValue;
  if val<0 then val := 0
  else if val>30000 then val:=30000;
  {seconds := val/1000;
  timeformattedstring := format('00 00 %.2d %.3d', [Trunc(seconds), Round(frac(seconds)*1000)] );
  fTimeout := StrToTime(timeformattedstring); }
  fTimeout := val * milliseconds;
  writeln(val, #32, FormatDateTime('hh:mm:ss.zzz', fTimeout));
end;

constructor TClientDB.Create;
begin
  inherited Create;
  FSQL := '';
  fConnection := TTCPConnection.Create;
  fConnection.OnReceiveMessage := @ReceiveMessage;
  fConnection.OnConnect := @DoConnect;
  fConnection.OnDisconnect := @DoDisConnect;
  FPort := DEFAULT_PORT;
  milliseconds := 1/(24 * 60 * 60 * 1000);
  Timeout := 10000;
end;

destructor TClientDB.Destroy;
begin
  Close;
  Disconnect;
  inherited Destroy;
end;

procedure TClientDB.Open;
var
  databuffer: TTCPSendBuffer;
begin
  if FState=dsBrowse then exit;
  if Length(FSQL)=0 then exit;
  if not fConnected then
     try
       Connect;
       fTimeOutTime := Now + fTimeout;
       while not fConnected do
         begin
           fConnection.CallAction;
           Application.ProcessMessages;
           if Now>=fTimeOutTime then Raise Exception.Create('Unable to connect to server');
         end;
     except
       FState := dsInactive;
       Exit;
     end;
  fWaiting := true;
  fState := dsOpening;
  databuffer := TTCPSendBuffer.Create(nil, nil);
  databuffer.Header := NewHeader(ADMIN_ID, fpmSQLQuery);
  databuffer.AddData(FSQL);
  fConnection.SendMessage(databuffer);
  fTimeOutTime := Now + fTimeout;
  while (fWaiting) do
        begin
          fConnection.CallAction;
          Application.ProcessMessages;
         if Now>fTimeOutTime then
            begin
              FState := dsInactive;
              fWaiting := false;
            end;
        end;
  if FRecordCount<1 then
     begin
       FState := dsInactive;
       fEOF := true;
       FQuery := FSQL;
     end;
  if FState=dsBrowse then FQuery := FSQL;
end;

procedure TClientDB.Close;
begin
  FState := dsInactive;
  ClearFields;
  fData.Clear;
  FRecNo := -1;
end;

procedure TClientDB.Refresh;
begin
  {Refresh posts any pending edits, and refetches the data in the dataset from the underlying database, and attempts to reposition the cursor on the same record as it was. This operation is not supported by all datasets, and should be used with care. The repositioning may not always succeed, in which case the cursor will be positioned on the first record in the dataset. This is in particular true for unidirectional datasets. Calling Refresh results in the triggering of the BeforeRefresh and AfterRefresh events. }
end;

function TClientDB.ExecRemoteSQL ( SQL: string; isUpdate: Boolean=false ) : Boolean;
var
  buf: TTCPSendBuffer;
  timeoutTime: Extended;
begin
  Result := false;
  buf := TTCPSendBuffer.Create(nil, nil);
  buf.Header := NewHeader(ADMIN_ID, fpmExecSQL);
  if isUpdate then buf.Header := NewHeader(ADMIN_ID, fpmExecSQL, fpdSQLUpdate)
  else buf.Header := NewHeader(ADMIN_ID, fpmExecSQL);
  writeln('TClientDB.ExecRemoteSQL');
  writeln(SQL);
  buf.AddData(SQL);
  fConnection.SendMessage(buf);
  timeoutTime := Now + fTimeout;
  fSuccess := false;
  while (not fSuccess) and (Now<timeoutTime) do
        fConnection.CallAction;
  Result := fSuccess;
end;

function TClientDB.Connect: Boolean;
begin
  Result := fConnection.Connection.Connect( fServer, FPort );
end;

procedure TClientDB.Disconnect;
begin
  fConnection.Connection.Disconnect(false);
end;

{ TDBData }

procedure TDBData.ClearFields;
var
  x: Integer;
begin
  for x := FieldCount-1 downto 0
      do Fields[x].Free;
  FieldCount := 0;
end;

end.

